home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / YAML / Dumper.pm < prev    next >
Encoding:
Perl POD Document  |  2010-01-02  |  16.8 KB  |  592 lines
  1. package YAML::Dumper;
  2.  
  3. use strict;
  4. use warnings;
  5. use YAML::Base;
  6. use YAML::Dumper::Base;
  7. use YAML::Node;
  8. use YAML::Types;
  9.  
  10. our $VERSION = '0.71';
  11. our @ISA     = 'YAML::Dumper::Base';
  12.  
  13. # Context constants
  14. use constant KEY       => 3;
  15. use constant BLESSED   => 4;
  16. use constant FROMARRAY => 5;
  17. use constant VALUE     => "\x07YAML\x07VALUE\x07";
  18.  
  19. # Common YAML character sets
  20. my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
  21. my $LIT_CHAR    = '|';    
  22.  
  23. #==============================================================================
  24. # OO version of Dump. YAML->new->dump($foo); 
  25. sub dump {
  26.     my $self = shift;
  27.     $self->stream('');
  28.     $self->document(0);
  29.     for my $document (@_) {
  30.         $self->{document}++;
  31.         $self->transferred({});
  32.         $self->id_refcnt({});
  33.         $self->id_anchor({});
  34.         $self->anchor(1);
  35.         $self->level(0);
  36.         $self->offset->[0] = 0 - $self->indent_width;
  37.         $self->_prewalk($document);
  38.         $self->_emit_header($document);
  39.         $self->_emit_node($document);
  40.     }
  41.     return $self->stream;
  42. }
  43.  
  44. # Every YAML document in the stream must begin with a YAML header, unless
  45. # there is only a single document and the user requests "no header".
  46. sub _emit_header {
  47.     my $self = shift;
  48.     my ($node) = @_;
  49.     if (not $self->use_header and 
  50.         $self->document == 1
  51.        ) {
  52.         $self->die('YAML_DUMP_ERR_NO_HEADER')
  53.           unless ref($node) =~ /^(HASH|ARRAY)$/;
  54.         $self->die('YAML_DUMP_ERR_NO_HEADER')
  55.           if ref($node) eq 'HASH' and keys(%$node) == 0;
  56.         $self->die('YAML_DUMP_ERR_NO_HEADER')
  57.           if ref($node) eq 'ARRAY' and @$node == 0;
  58.         # XXX Also croak if aliased, blessed, or ynode
  59.         $self->headless(1);
  60.         return;
  61.     }
  62.     $self->{stream} .= '---';
  63. # XXX Consider switching to 1.1 style
  64.     if ($self->use_version) {
  65. #         $self->{stream} .= " #YAML:1.0";
  66.     }
  67. }
  68.  
  69. # Walk the tree to be dumped and keep track of its reference counts.
  70. # This function is where the Dumper does all its work. All type
  71. # transfers happen here.
  72. sub _prewalk {
  73.     my $self = shift;
  74.     my $stringify = $self->stringify;
  75.     my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
  76.  
  77.     # Handle typeglobs
  78.     if ($type eq 'GLOB') {
  79.         $self->transferred->{$node_id} =
  80.           YAML::Type::glob->yaml_dump($_[0]);
  81.         $self->_prewalk($self->transferred->{$node_id});
  82.         return;
  83.     }
  84.  
  85.     # Handle regexps
  86.     if (ref($_[0]) eq 'Regexp') {  
  87.         return;
  88.     }
  89.  
  90.     # Handle Purity for scalars.
  91.     # XXX can't find a use case yet. Might be YAGNI.
  92.     if (not ref $_[0]) {
  93.         $self->{id_refcnt}{$node_id}++ if $self->purity;
  94.         return;
  95.     }
  96.  
  97.     # Make a copy of original
  98.     my $value = $_[0];
  99.     ($class, $type, $node_id) = $self->node_info($value, $stringify);
  100.  
  101.     # Must be a stringified object.
  102.     return if (ref($value) and not $type);
  103.  
  104.     # Look for things already transferred.
  105.     if ($self->transferred->{$node_id}) {
  106.         (undef, undef, $node_id) = (ref $self->transferred->{$node_id})
  107.           ? $self->node_info($self->transferred->{$node_id}, $stringify)
  108.           : $self->node_info(\ $self->transferred->{$node_id}, $stringify);
  109.         $self->{id_refcnt}{$node_id}++;
  110.         return;
  111.     }
  112.  
  113.     # Handle code refs
  114.     if ($type eq 'CODE') {
  115.         $self->transferred->{$node_id} = 'placeholder';
  116.         YAML::Type::code->yaml_dump(
  117.             $self->dump_code,
  118.             $_[0], 
  119.             $self->transferred->{$node_id}
  120.         );
  121.         ($class, $type, $node_id) = 
  122.           $self->node_info(\ $self->transferred->{$node_id}, $stringify);
  123.         $self->{id_refcnt}{$node_id}++;
  124.         return;
  125.     }
  126.  
  127.     # Handle blessed things
  128.     if (defined $class) {
  129.         if ($value->can('yaml_dump')) {
  130.             $value = $value->yaml_dump;
  131.         }
  132.         elsif ($type eq 'SCALAR') {
  133.             $self->transferred->{$node_id} = 'placeholder';
  134.             YAML::Type::blessed->yaml_dump
  135.               ($_[0], $self->transferred->{$node_id});
  136.             ($class, $type, $node_id) =
  137.               $self->node_info(\ $self->transferred->{$node_id}, $stringify);
  138.             $self->{id_refcnt}{$node_id}++;
  139.             return;
  140.         }
  141.         else {
  142.             $value = YAML::Type::blessed->yaml_dump($value);
  143.         }
  144.         $self->transferred->{$node_id} = $value;
  145.         (undef, $type, $node_id) = $self->node_info($value, $stringify);
  146.     }
  147.  
  148.     # Handle YAML Blessed things
  149.     if (defined YAML->global_object()->{blessed_map}{$node_id}) {
  150.         $value = YAML->global_object()->{blessed_map}{$node_id};
  151.         $self->transferred->{$node_id} = $value;
  152.         ($class, $type, $node_id) = $self->node_info($value, $stringify);
  153.         $self->_prewalk($value);
  154.         return;
  155.     }
  156.  
  157.     # Handle hard refs
  158.     if ($type eq 'REF' or $type eq 'SCALAR') {
  159.         $value = YAML::Type::ref->yaml_dump($value);
  160.         $self->transferred->{$node_id} = $value;
  161.         (undef, $type, $node_id) = $self->node_info($value, $stringify);
  162.     }
  163.  
  164.     # Handle ref-to-glob's
  165.     elsif ($type eq 'GLOB') {
  166.         my $ref_ynode = $self->transferred->{$node_id} =
  167.           YAML::Type::ref->yaml_dump($value);
  168.  
  169.         my $glob_ynode = $ref_ynode->{&VALUE} = 
  170.           YAML::Type::glob->yaml_dump($$value);
  171.  
  172.         (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
  173.         $self->transferred->{$node_id} = $glob_ynode;
  174.         $self->_prewalk($glob_ynode);
  175.         return;
  176.     }
  177.  
  178.     # Increment ref count for node
  179.     return if ++($self->{id_refcnt}{$node_id}) > 1;
  180.  
  181.     # Keep on walking
  182.     if ($type eq 'HASH') {
  183.         $self->_prewalk($value->{$_})
  184.             for keys %{$value};
  185.         return;
  186.     }
  187.     elsif ($type eq 'ARRAY') {
  188.         $self->_prewalk($_)
  189.             for @{$value};
  190.         return;
  191.     }
  192.  
  193.     # Unknown type. Need to know about it.
  194.     $self->warn(<<"...");
  195. YAML::Dumper can't handle dumping this type of data.
  196. Please report this to the author.
  197.  
  198. id:    $node_id
  199. type:  $type
  200. class: $class
  201. value: $value
  202.  
  203. ...
  204.  
  205.     return;
  206. }
  207.  
  208. # Every data element and sub data element is a node.
  209. # Everything emitted goes through this function.
  210. sub _emit_node {
  211.     my $self = shift;
  212.     my ($type, $node_id);
  213.     my $ref = ref($_[0]);
  214.     if ($ref) {
  215.         if ($ref eq 'Regexp') {
  216.             $self->_emit(' !!perl/regexp');
  217.             $self->_emit_str("$_[0]");
  218.             return;
  219.         }
  220.         (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify);
  221.     }
  222.     else {
  223.         $type = $ref || 'SCALAR';
  224.         (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
  225.     }
  226.  
  227.     my ($ynode, $tag) = ('') x 2;
  228.     my ($value, $context) = (@_, 0);
  229.  
  230.     if (defined $self->transferred->{$node_id}) {
  231.         $value = $self->transferred->{$node_id};
  232.         $ynode = ynode($value);
  233.         if (ref $value) {
  234.             $tag = defined $ynode ? $ynode->tag->short : '';
  235.             (undef, $type, $node_id) =
  236.               $self->node_info($value, $self->stringify);
  237.         }
  238.         else {
  239.             $ynode = ynode($self->transferred->{$node_id});
  240.             $tag = defined $ynode ? $ynode->tag->short : '';
  241.             $type = 'SCALAR';
  242.             (undef, undef, $node_id) = 
  243.               $self->node_info(
  244.                   \ $self->transferred->{$node_id},
  245.                   $self->stringify
  246.               );
  247.         }
  248.     }
  249.     elsif ($ynode = ynode($value)) {
  250.         $tag = $ynode->tag->short;
  251.     }
  252.  
  253.     if ($self->use_aliases) {
  254.         $self->{id_refcnt}{$node_id} ||= 0;
  255.         if ($self->{id_refcnt}{$node_id} > 1) {
  256.             if (defined $self->{id_anchor}{$node_id}) {
  257.                 $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n";
  258.                 return;
  259.             }
  260.             my $anchor = $self->anchor_prefix . $self->{anchor}++;
  261.             $self->{stream} .= ' &' . $anchor;
  262.             $self->{id_anchor}{$node_id} = $anchor;
  263.         }
  264.     }
  265.  
  266.     return $self->_emit_str("$value")   # Stringified object
  267.       if ref($value) and not $type;
  268.     return $self->_emit_scalar($value, $tag)
  269.       if $type eq 'SCALAR' and $tag;
  270.     return $self->_emit_str($value)
  271.       if $type eq 'SCALAR';
  272.     return $self->_emit_mapping($value, $tag, $node_id, $context)
  273.       if $type eq 'HASH';
  274.     return $self->_emit_sequence($value, $tag)
  275.       if $type eq 'ARRAY';
  276.     $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
  277.     return $self->_emit_str("$value");
  278. }
  279.  
  280. # A YAML mapping is akin to a Perl hash. 
  281. sub _emit_mapping {
  282.     my $self = shift;
  283.     my ($value, $tag, $node_id, $context) = @_;
  284.     $self->{stream} .= " !$tag" if $tag;
  285.  
  286.     # Sometimes 'keys' fails. Like on a bad tie implementation.
  287.     my $empty_hash = not(eval {keys %$value});
  288.     $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
  289.     return ($self->{stream} .= " {}\n") if $empty_hash;
  290.  
  291.     # If CompressSeries is on (default) and legal is this context, then
  292.     # use it and make the indent level be 2 for this node.
  293.     if ($context == FROMARRAY and
  294.         $self->compress_series and
  295.         not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash)
  296.        ) {
  297.         $self->{stream} .= ' ';
  298.         $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
  299.     }
  300.     else {
  301.         $context = 0;
  302.         $self->{stream} .= "\n"
  303.           unless $self->headless && not($self->headless(0));
  304.         $self->offset->[$self->level+1] =
  305.           $self->offset->[$self->level] + $self->indent_width;
  306.     }
  307.  
  308.     $self->{level}++;
  309.     my @keys;
  310.     if ($self->sort_keys == 1) {
  311.         if (ynode($value)) {
  312.             @keys = keys %$value;
  313.         }
  314.         else {
  315.             @keys = sort keys %$value;
  316.         }
  317.     }
  318.     elsif ($self->sort_keys == 2) {
  319.         @keys = sort keys %$value;
  320.     }
  321.     # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
  322.     elsif (ref($self->sort_keys) eq 'ARRAY') {
  323.         my $i = 1;
  324.         my %order = map { ($_, $i++) } @{$self->sort_keys};
  325.         @keys = sort {
  326.             (defined $order{$a} and defined $order{$b})
  327.               ? ($order{$a} <=> $order{$b})
  328.               : ($a cmp $b);
  329.         } keys %$value;
  330.     }
  331.     else {
  332.         @keys = keys %$value;
  333.     }
  334.     # Force the YAML::VALUE ('=') key to sort last.
  335.     if (exists $value->{&VALUE}) {
  336.         for (my $i = 0; $i < @keys; $i++) {
  337.             if ($keys[$i] eq &VALUE) {
  338.                 splice(@keys, $i, 1);
  339.                 push @keys, &VALUE;
  340.                 last;
  341.             }
  342.         }
  343.     }
  344.  
  345.     for my $key (@keys) {
  346.         $self->_emit_key($key, $context);
  347.         $context = 0;
  348.         $self->{stream} .= ':';
  349.         $self->_emit_node($value->{$key});
  350.     }
  351.     $self->{level}--;
  352. }
  353.  
  354. # A YAML series is akin to a Perl array.
  355. sub _emit_sequence {
  356.     my $self = shift;
  357.     my ($value, $tag) = @_;
  358.     $self->{stream} .= " !$tag" if $tag;
  359.  
  360.     return ($self->{stream} .= " []\n") if @$value == 0;
  361.         
  362.     $self->{stream} .= "\n"
  363.       unless $self->headless && not($self->headless(0));
  364.  
  365.     # XXX Really crufty feature. Better implemented by ynodes.
  366.     if ($self->inline_series and
  367.         @$value <= $self->inline_series and
  368.         not (scalar grep {ref or /\n/} @$value)
  369.        ) {
  370.         $self->{stream} =~ s/\n\Z/ /;
  371.         $self->{stream} .= '[';
  372.         for (my $i = 0; $i < @$value; $i++) {
  373.             $self->_emit_str($value->[$i], KEY);
  374.             last if $i == $#{$value};
  375.             $self->{stream} .= ', ';
  376.         }
  377.         $self->{stream} .= "]\n";
  378.         return;
  379.     }
  380.  
  381.     $self->offset->[$self->level + 1] =
  382.       $self->offset->[$self->level] + $self->indent_width;
  383.     $self->{level}++;
  384.     for my $val (@$value) {
  385.         $self->{stream} .= ' ' x $self->offset->[$self->level];
  386.         $self->{stream} .= '-';
  387.         $self->_emit_node($val, FROMARRAY);
  388.     }
  389.     $self->{level}--;
  390. }
  391.  
  392. # Emit a mapping key
  393. sub _emit_key {
  394.     my $self = shift;
  395.     my ($value, $context) = @_;
  396.     $self->{stream} .= ' ' x $self->offset->[$self->level]
  397.       unless $context == FROMARRAY;
  398.     $self->_emit_str($value, KEY);
  399. }
  400.  
  401. # Emit a blessed SCALAR
  402. sub _emit_scalar {
  403.     my $self = shift;
  404.     my ($value, $tag) = @_;
  405.     $self->{stream} .= " !$tag";
  406.     $self->_emit_str($value, BLESSED);
  407. }
  408.  
  409. sub _emit {
  410.     my $self = shift;
  411.     $self->{stream} .= join '', @_;
  412. }
  413.  
  414. # Emit a string value. YAML has many scalar styles. This routine attempts to
  415. # guess the best style for the text.
  416. sub _emit_str {
  417.     my $self = shift;
  418.     my $type = $_[1] || 0;
  419.  
  420.     # Use heuristics to find the best scalar emission style.
  421.     $self->offset->[$self->level + 1] =
  422.       $self->offset->[$self->level] + $self->indent_width;
  423.     $self->{level}++;
  424.  
  425.     my $sf = $type == KEY ? '' : ' ';
  426.     my $sb = $type == KEY ? '? ' : ' ';
  427.     my $ef = $type == KEY ? '' : "\n";
  428.     my $eb = "\n";
  429.  
  430.     while (1) {
  431.         $self->_emit($sf),
  432.         $self->_emit_plain($_[0]),
  433.         $self->_emit($ef), last 
  434.           if not defined $_[0];
  435.         $self->_emit($sf, '=', $ef), last
  436.           if $_[0] eq VALUE;
  437.         $self->_emit($sf),
  438.         $self->_emit_double($_[0]),
  439.         $self->_emit($ef), last
  440.           if $_[0] =~ /$ESCAPE_CHAR/;
  441.         if ($_[0] =~ /\n/) {
  442.             $self->_emit($sb),
  443.             $self->_emit_block($LIT_CHAR, $_[0]),
  444.             $self->_emit($eb), last
  445.               if $self->use_block;
  446.               Carp::cluck "[YAML] \$UseFold is no longer supported"
  447.               if $self->use_fold;
  448.             $self->_emit($sf),
  449.             $self->_emit_double($_[0]),
  450.             $self->_emit($ef), last
  451.               if length $_[0] <= 30;
  452.             $self->_emit($sf),
  453.             $self->_emit_double($_[0]),
  454.             $self->_emit($ef), last
  455.               if $_[0] !~ /\n\s*\S/;
  456.             $self->_emit($sb),
  457.             $self->_emit_block($LIT_CHAR, $_[0]),
  458.             $self->_emit($eb), last;
  459.         }
  460.         $self->_emit($sf),
  461.         $self->_emit_plain($_[0]),
  462.         $self->_emit($ef), last
  463.           if $self->is_valid_plain($_[0]);
  464.         $self->_emit($sf),
  465.         $self->_emit_double($_[0]),
  466.         $self->_emit($ef), last
  467.           if $_[0] =~ /'/;
  468.         $self->_emit($sf),
  469.         $self->_emit_single($_[0]),
  470.         $self->_emit($ef);
  471.         last;
  472.     }
  473.  
  474.     $self->{level}--;
  475.  
  476.     return;
  477. }
  478.  
  479. # Check whether or not a scalar should be emitted as an plain scalar.
  480. sub is_valid_plain {
  481.     my $self = shift;
  482.     return 0 unless length $_[0];
  483.     # refer to YAML::Loader::parse_inline_simple()
  484.     return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/;
  485.     return 0 if $_[0] =~ /[\{\[\]\},]/;
  486.     return 0 if $_[0] =~ /[:\-\?]\s/;
  487.     return 0 if $_[0] =~ /\s#/;
  488.     return 0 if $_[0] =~ /\:(\s|$)/;
  489.     return 0 if $_[0] =~ /[\s\|\>]$/;
  490.     return 1;
  491. }
  492.  
  493. sub _emit_block {
  494.     my $self = shift;
  495.     my ($indicator, $value) = @_;
  496.     $self->{stream} .= $indicator;
  497.     $value =~ /(\n*)\Z/;
  498.     my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
  499.     $value = '~' if not defined $value;
  500.     $self->{stream} .= $chomp;
  501.     $self->{stream} .= $self->indent_width if $value =~ /^\s/;
  502.     $self->{stream} .= $self->indent($value);
  503. }
  504.  
  505. # Plain means that the scalar is unquoted.
  506. sub _emit_plain {
  507.     my $self = shift;
  508.     $self->{stream} .= defined $_[0] ? $_[0] : '~';
  509. }
  510.  
  511. # Double quoting is for single lined escaped strings.
  512. sub _emit_double {
  513.     my $self = shift;
  514.     (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
  515.     $self->{stream} .= qq{"$escaped"};
  516. }
  517.  
  518. # Single quoting is for single lined unescaped strings.
  519. sub _emit_single {
  520.     my $self = shift;
  521.     my $item = shift;
  522.     $item =~ s{'}{''}g;
  523.     $self->{stream} .= "'$item'";
  524. }
  525.  
  526. #==============================================================================
  527. # Utility subroutines.
  528. #==============================================================================
  529.  
  530. # Indent a scalar to the current indentation level.
  531. sub indent {
  532.     my $self = shift;
  533.     my ($text) = @_;
  534.     return $text unless length $text;
  535.     $text =~ s/\n\Z//;
  536.     my $indent = ' ' x $self->offset->[$self->level];
  537.     $text =~ s/^/$indent/gm;
  538.     $text = "\n$text";
  539.     return $text;
  540. }
  541.  
  542. # Escapes for unprintable characters
  543. my @escapes = qw(\0   \x01 \x02 \x03 \x04 \x05 \x06 \a
  544.                  \x08 \t   \n   \v   \f   \r   \x0e \x0f
  545.                  \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
  546.                  \x18 \x19 \x1a \e   \x1c \x1d \x1e \x1f
  547.                 );
  548.  
  549. # Escape the unprintable characters
  550. sub escape {
  551.     my $self = shift;
  552.     my ($text) = @_;
  553.     $text =~ s/\\/\\\\/g;
  554.     $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
  555.     return $text;
  556. }
  557.  
  558. 1;
  559.  
  560. __END__
  561.  
  562. =head1 NAME
  563.  
  564. YAML::Dumper - YAML class for dumping Perl objects to YAML
  565.  
  566. =head1 SYNOPSIS
  567.  
  568.     use YAML::Dumper;
  569.     my $dumper = YAML::Dumper->new;
  570.     $dumper->indent_width(4);
  571.     print $dumper->dump({foo => 'bar'});
  572.  
  573. =head1 DESCRIPTION
  574.  
  575. YAML::Dumper is the module that YAML.pm used to serialize Perl objects to
  576. YAML. It is fully object oriented and usable on its own.
  577.  
  578. =head1 AUTHOR
  579.  
  580. Ingy d├╢t Net <ingy@cpan.org>
  581.  
  582. =head1 COPYRIGHT
  583.  
  584. Copyright (c) 2006. Ingy d├╢t Net. All rights reserved.
  585.  
  586. This program is free software; you can redistribute it and/or modify it
  587. under the same terms as Perl itself.
  588.  
  589. See L<http://www.perl.com/perl/misc/Artistic.html>
  590.  
  591. =cut
  592.